home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / forth / amiga / amigaker.arc / 01.runtime next >
Text File  |  1987-12-30  |  12KB  |  324 lines
  1. ;     01.runtime
  2. ;
  3. ;  Runtime procedures
  4. ;
  5.  
  6. nest              move.l   ip,-(rp)          ;label - nest
  7.                   move.l   w,ip              ; nest a level, used by colon
  8.                   jmp      (a3)              ; definition
  9.  
  10. * exit                                       ;exit a colon definition
  11.                   dc.w     -1
  12.                   dc.l     link1
  13. link1             set      *-4
  14.                   dc.b     $84,'exi',$80!'t'
  15.                   cnop     0,2
  16. _exit             dc.l     *+4
  17.                   move.l   (rp)+,ip
  18.                   jmp      (a3)
  19.  
  20. * unnest                                     ;same as exit
  21.                   dc.w     -1
  22.                   dc.l     link1
  23. link1             set      *-4
  24.                   dc.b     $86,'unnes',$80!'t'
  25.                   cnop     0,2
  26. _unnest           dc.l     _exit+4
  27.  
  28. dodoes            move.l   ip,-(rp)          ;label - dodoes (first nest)
  29.                   move.l   (sp)+,ip          ; (then get address, jsr )
  30. docreate          move.l   w,-(sp)           ;label - docreate
  31.                   jmp      (a3)
  32.  
  33. doconstant        move.l   (w),-(sp)         ;label - doconstants
  34.                   jmp      (a3)
  35.  
  36. * (lit)                                      ;fetch inline long constant
  37.                   dc.w     -1
  38.                   dc.l     link0
  39. link0             set      *-4
  40.                   dc.b     $85,'(lit',$80!')'
  41.                   cnop     0,2
  42. _nest_lit         dc.l     *+4
  43.                   move.l   (ip)+,-(sp)
  44.                   jmp      (a3)
  45.  
  46. * branch                                     ;jump to the inline address
  47.                   dc.w     -1
  48.                   dc.l     link2
  49. link2             set      *-4
  50.                   dc.b     $86,'branc',$80!'h'
  51.                   cnop     0,2
  52. _branch           dc.l     *+4
  53. bran1             move.l   (ip),ip
  54.                   jmp      (a3)
  55.  
  56. * ?branch                                    ;take the branch if tos is
  57.                   dc.w     -1
  58.                   dc.l     link3             ; false otherwise continue
  59. link3             set      *-4               ; note. it is the opposite
  60.                   dc.b     $87,'?branc',$80!'h'   ; of what it is used for,
  61.                   cnop     0,2               ; logically that is.
  62. _question_branch  dc.l     *+4
  63.                   tst.l    (sp)+
  64.                   beq.s    bran1
  65.                   addq.l   #4,ip
  66.                   jmp      (a3)
  67.  
  68. * (loop)       ;dictionary:(do)|cc|...|(loop)|bb|
  69.                ;                   ^bb           ^cc
  70.                   dc.w     -1
  71.                   dc.l     link0
  72. link0             set      *-4
  73.                   dc.b     $86,'(loop',$80!')'
  74.                   cnop     0,2
  75. _nest_loop        dc.l     *+4               ;runtime for LOOP
  76.                   addq.l   #1,(rp)           ;loops are 32 bits also
  77.                   bvc.s    bran1
  78. loop_end          addq.l   #8,rp             ;get rid off start/index
  79.                   addq.l   #4,rp             ;and drop the leave address
  80.                   addq.l   #4,ip             ;jump over DO address
  81.                   jmp      (a3)
  82.  
  83. * (+loop)
  84.                   dc.w     -1
  85.                   dc.l     link0
  86. link0             set      *-4
  87.                   dc.b     $87,'(+loop',$80!')'
  88.                   cnop     0,2
  89. _nest_plus_loop   dc.l     *+4               ;runtime for +loop
  90.                   move.l   (sp)+,d0          ;plus parameter can be any
  91.                   add.l    d0,(rp)           ; size up to 2^32
  92.                   bvc.s    bran1
  93.                   bra.s    loop_end          ;same as above
  94.  
  95. * (do)            ; (s limit initial  -- )
  96.                   dc.w     -1
  97.                   dc.l     link0
  98. link0             set      *-4
  99.                   dc.b     $84,'(do',$80!')'
  100.                   cnop     0,2
  101. _nest_do          dc.l     *+4               ;runtime for do
  102.                   movem.l  (sp)+,d0-d1       ;d0=initial d1=limit
  103. pdo               move.l   (ip)+,-(rp)
  104.                   add.l    #$80000000,d1     ;have to add to make bvc work
  105.                   move.l   d1,-(rp)          ;store adjusted length
  106.                   sub.l    d1,d0
  107.                   move.l   d0,-(rp)          ;index
  108.                   jmp      (a3)
  109.  
  110. * (?do)           ; (s limit initial -- )    same as do but will not start
  111.                   dc.w     -1
  112.                   dc.l     link0             ; if initial=limit
  113. link0             set      *-4
  114.                   dc.b     $85,'(?do',$80!')'
  115.                   cnop     0,2
  116. _nest_question_do dc.l     *+4
  117.                   movem.l  (sp)+,d0-d1
  118.                   cmp.l    d0,d1
  119.                   bne.s    pdo
  120.                   bra      bran1
  121.  
  122. * bounds          ; (s addr len -- lim first ) 
  123.                   dc.w     -1
  124.                   dc.l     link2
  125. link2             set      *-4
  126.                   dc.b     $86,'bound',$80!'s'
  127.                   cnop     0,2
  128. _bounds           dc.l     *+4
  129.                   move.l   (sp)+,d0
  130.                   move.l   (sp),d1
  131.                   add.l    d0,(sp)
  132.                   move.l   d1,-(sp)
  133.                   jmp      (a3)
  134.  
  135. * execute         ; (s cfa -- )  execute the word whose code field
  136.                   ; address is on the stack
  137.                   dc.w     -1
  138.                   dc.l     link1
  139. link1             set      *-4
  140.                   dc.b     $87,'execut',$80!'e'
  141.                   cnop     0,2
  142. _execute          dc.l     *+4
  143.                   move.l   (sp)+,w
  144.                   move.l   (w)+,a0
  145.                   jmp      (a0)
  146.  
  147. * perform         ; (s addr of cfa -- ) the address of the cfa is
  148.                   dc.w     -1
  149.                   dc.l     link0             ; on the stack
  150. link0             set      *-4
  151.                   dc.b     $87,'perfor',$80!'m'
  152.                   cnop     0,2
  153. _perform          dc.l     *+4
  154.                   move.l   (sp)+,w
  155. dodefer           move.l   (w)+,w            ;label - dodefer
  156.                   move.l   (w)+,a0
  157.                   jmp      (a0)
  158.  
  159. * go              ; (s addr -- )  execute code at the address
  160.                   dc.w     -1
  161.                   dc.l     link3
  162. link3             set      *-4
  163.                   dc.b     $82,'g',$80!'o'
  164.                   cnop     0,2
  165. _go               dc.l     *+4
  166.                   rts
  167.  
  168. * noop            ; (s -- )         Do nothing
  169.                   dc.w     -1
  170.                   dc.l     link2
  171. link2             set      *-4
  172.                   dc.b     $84,'noo',$80!'p'
  173.                   cnop     0,2
  174. _noop             dc.l     *+4
  175.                   jmp      (a3)
  176.  
  177. * i               ; (s -- n )   Return the current loop index.
  178.                   dc.w     -1
  179.                   dc.l     link1
  180. link1             set      *-4
  181.                   dc.b     $81,$80!'i'
  182.                   cnop     0,2
  183. _i                dc.l     *+4
  184.                   move.l   (rp),d0
  185.                   add.l    4(rp),d0
  186.                   move.l   d0,-(sp)
  187.                   jmp      (a3)
  188.  
  189. * j               ; (s -- n )       Return the index of the inner loop
  190.                   dc.w     -1
  191.                   dc.l     link2
  192. link2             set      *-4
  193.                   dc.b     $81,$80!'j'
  194.                   cnop     0,2
  195. _j                dc.l     *+4
  196.                   move.l   12(rp),d0
  197.                   add.l    16(rp),d0
  198.                   move.l   d0,-(sp)
  199.                   jmp      (a3)
  200.  
  201. * (leave)         ; (s -- )         Exit a loop immediately
  202.                   dc.w     -1
  203.                   dc.l     link0
  204. link0             set      *-4
  205.                   dc.b     $87,'(leave',$80!')'
  206.                   cnop     0,2
  207. _nest_leave       dc.l     *+4
  208. pleave            addq.l   #8,rp    ;get rid off start/index
  209.                   move.l   (rp)+,ip
  210.                   jmp      (a3)
  211.  
  212. * (?leave)        ; (s f -- )       Exit loop if True
  213.                   dc.w     -1
  214.                   dc.l     link0
  215. link0             set      *-4
  216.                   dc.b     $88,'(?leave',$80!')'
  217.                   cnop     0,2
  218. _nest_question_leave
  219.                   dc.l     *+4
  220.                   tst.l    (sp)+
  221.                   bne.s    pleave
  222.                   jmp      (a3)
  223.  
  224. * @               ; (s addr -- n )  fetch value (32bit) at address
  225.                   dc.w     -1
  226.                   dc.l     link0
  227. link0             set      *-4
  228.                   dc.b     $81,$80!'@'
  229.                   cnop     0,2
  230. _fetch            dc.l     *+4
  231.                   move.l   (sp),a0
  232.                   move.l   (a0),(sp)
  233.                   jmp      (a3)
  234.  
  235. * !               ; (s addr n -- )  Store value n at address
  236.                   dc.w     -1
  237.                   dc.l     link1
  238. link1             set      *-4
  239.                   dc.b     $81,$80!'!'
  240.                   cnop     0,2
  241. _store            dc.l     *+4
  242.                   move.l   (sp)+,a0
  243.                   move.l   (sp)+,(a0)
  244.                   jmp      (a3)
  245.  
  246. * w@              ; (s addr -- wn )  Fetch 16bit value from address
  247.                   dc.w     -1
  248.                   dc.l     link3
  249. link3             set      *-4
  250.                   dc.b     $82,'w',$80!'@'
  251.                   cnop     0,2
  252. _w_fetch          dc.l     *+4
  253.                   clr.l    d0
  254.                   move.l   (sp),a0
  255.                   move.w   (a0),d0
  256.                   move.l   d0,(sp)
  257.                   jmp      (a3)
  258.  
  259. * w!              ; (s addr wn -- ) Store 16bit value at address
  260.                   dc.w     -1
  261.                   dc.l     link3
  262. link3             set      *-4
  263.                   dc.b     $82,'w',$80!'!'
  264.                   cnop     0,2
  265. _w_store          dc.l     *+4
  266.                   move.l   (sp)+,a0
  267.                   move.l   (sp)+,d0
  268.                   move.w   d0,(a0)
  269.                   jmp      (a3)
  270.  
  271. * c@              ; (s addr -- c )  Fetch character at address
  272.                   dc.w     -1
  273.                   dc.l     link3
  274. link3             set      *-4
  275.                   dc.b     $82,'c',$80!'@'
  276.                   cnop     0,2
  277. _c_fetch          dc.l     *+4
  278.                   clr.l    d0
  279.                   move.l   (sp),a0
  280.                   move.b   (a0),d0
  281.                   move.l   d0,(sp)
  282.                   jmp      (a3)
  283.  
  284. * c!              ; (s addr c -- ) Store character at address
  285.                   dc.w     -1
  286.                   dc.l     link3
  287. link3             set      *-4
  288.                   dc.b     $82,'c',$80!'!'
  289.                   cnop     0,2
  290. _c_store          dc.l     *+4
  291.                   move.l   (sp)+,a0
  292.                   move.l   (sp)+,d0
  293.                   move.b   d0,(a0)
  294.                   jmp      (a3)
  295.  
  296. * cmove           ; (s from to count -- ) byte move from low to high addr
  297.                   dc.w     -1
  298.                   dc.l     link3
  299. link3             set      *-4
  300.                   dc.b     $85,'cmov',$80!'e'
  301.                   cnop     0,2
  302. _cmove            dc.l     *+4
  303.                   movem.l  (sp)+,d0/a0-a1
  304.                   bra.s    cmove3
  305. cmove             move.b   (a1)+,(a0)+
  306. cmove3            dbra     d0,cmove
  307.                   jmp      (a3)
  308.  
  309. * cmove>          ; (s from to count -- ) byte move from high to low addr
  310.                   dc.w     -1
  311.                   dc.l     link3
  312. link3             set      *-4
  313.                   dc.b     $86,'cmove',$80!$3e
  314.                   cnop     0,2
  315. _cmove_up         dc.l     *+4               ;NOTE: only 16bit length!!
  316.                   movem.l  (sp)+,d0/a0-a1    ;  or max 2^16
  317. cmove1            add.l    d0,a0             ;ALSO: cmove1 is jumped to
  318.                   add.l    d0,a1             ;      by ROLL.
  319.                   bra.s    cmove4
  320. cmove2            move.b   -(a1),-(a0)
  321. cmove4            dbra     d0,cmove2
  322.                   jmp      (a3)
  323.  
  324.